00200	C  SUBRS. VLINE, ASKIT, GRED, LPEN, DELETE, DPYNEW, PLTCMD
00210	C*****  SAVIT, LISTP, FIXUP   ***************
00300	
09700	
09800		SUBROUTINE VLINE(RJC,RJD,RJE,RJF)
09900		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
10000	6	TYPE 3
10100		ACCEPT F78F,RJC,RJD,RJE,RJF
10110		REREAD FA1,ASK
10200		IF(RJC.GE.99)RETURN
10300		IF(ASK.NE.'L')GO TO 66
10350	C  TYPE 'L' FOR LIGHT-PEN
10400		K=-1
10500	67	RJD=RY
10600		CALL LPEN(RJC,RY,RX)
10700		IF(RJC.GE.99)RETURN
10750		K=-K
10775		IF(K.GT.0)GO TO 67
10800		RJE=RY
10900	C LIGHT PEN IS READ TWICE
11000	66	ASK=-1
11100		IF(RJF.LT.100)GO TO 1
11200		RJF=RJF-100
11300	C  FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
11400		ASK=0
11500	1	CALL BOX(-1,RJD,1)
11600		CALL BOX(-2,RJE,1)
11700	C  PUTS UP TWO VERTICAL LINES
11800	3	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
11900		END
12000	
12100		SUBROUTINE ASKIT
12200		COMMON /DPY/ST(4000),WDS(250),MEDIT,IGO
12500		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
12600		COMMON /XRN/RN(4000)
12650		IGO=0
12700		CALL DPYNEW
12800		X=ST(2)
12900		CALL BOX(JY,RN(JY+3),STFF)
13000		ST(2)=X
13100		TYPE 1
13200		ACCEPT FA1,K
13300		IF(K.EQ.'G')ASK=-1
13400		CALL DPYNEW
13450		IGO=1
13500	1	FORMAT(' N=NO, <CR>=YES, G=GO  '$)
13700		END
13800	
13900		SUBROUTINE GRED
13910		COMMON /DPY/IST(4000),IWDS(250),MEDIT,IGO
14100		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
14300		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
14400		COMMON RJB,JA,J,JB,RJQ(6),RC,IZ,RX,K,RY,A,B,C,D,JZ,JW,
14450		1 NX,JY,RB,JQ(20) /XRN/RN(4000) /ALF/INP(72),ML
14500		COMMON /PTR/PWDS(250),ITEM,L,I,IX/POSI/STFF(8),JJB,POS
14600		DIMENSION R(8,100)
14900	
14950		EQUIVALENCE (R,RN(3001)),(IST2,IST(2))
15000		RC=999
15100		RSTF=RC
15300	CC **CAN'T GET HERE ***IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
15400	C  LEAVES ROUTINE
15500	7	CALL VLINE(RJQ(1),Z,POS,RX)
15600	C  PUTS UP TWO VERTICAL LINES
15620		IF(RJQ(1).LT.99)GO TO 70
15630		JA=98
15640		RETURN
15700	70	IF(POS.EQ.0)POS=200
15800	C  0,0  DOES WHOLE STAFF
15900		IF(INP(1).NE.'A')GO TO 4
16000		TYPE 55
16100		ACCEPT F78F,V
16150		REREAD FA1,K
16175	C  TYPE 'L' FOR LIGHT PEN
16200		IF(V(1).GE.99)GO TO 7
16300		IF(K.NE.'L')GO TO 66
16400		DO 67 K=1,2
16500		V(2)=RY
16600		CALL LPEN(V(1),RY,RX)
16700	67	IF(V(1).GE.99)GO TO 7
16800		V(3)=RY
16900	66	JA=0
16910		IZ=0
16955	C  COUNTER
17000		GO TO 14
17100	4	JA=98
17200	C  FOR DELETIONS
17300	C  STF.N, -99    -- DELETES ALL BUT STAFF N.
17310		IF(Z.NE.-99)GO TO 14
17320		RSTF=RJQ(1)
17330		RJQ(1)=99
17400	14	NX=0
17500	C  LOOP STARTS HERE
17550		J=0
17600	140	NX=NX+1
17700	142	JY=PWDS(NX)
17800		RB=RN(JY+2)
17900		IF(RTLINE(JY).OR.RB.LT.Z.OR.RB.GT.POS)GO TO 6
17910		IF(RN(JY+3).EQ.RSTF)GO TO 6
17920	C  FOR -99 DELETES.
18000		RB=RN(JY+1)
18100		IF(V(1).NE.12.AND.RC.EQ.999)GO TO 143
18200	C  USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
18205	C  SET 12 TO 1 WITH CODE 8 TO INVERT SLURS ONLY
18300		RC=0
18400		IF(RB.EQ.8.OR.(RB.EQ.9.AND.RX.EQ.1))GO TO 141
18500	143	IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
18600		IF(ASK)GO TO 100
18700		CALL ASKIT
18800		IF(K.EQ.'N')GO TO 6
18900		IF(K.EQ.'X')GO TO 19
19000	100	IF(INP(1).EQ.'A')GO TO 141
19100		IF(J)GO TO 40
19110		J=-1
19120		K=NX
19130	41	IZ=NX
19140		IF(NX.LT.ITEM)GO TO 140
19150	40	IF(NX-IZ.EQ.1)GO TO 41
19160	C  GO BACK FOR MORE - IF IN RIGHT ORDER.
19170	C  RANGE TO DEL. = K→NX
19190	45	J=IZ+1
19195		A=PWDS(K)
19200		B=PWDS(J)-A
19210		JZ=IWDS(K)
19220		JB=IWDS(J)-JZ
19230		J=J-K
19240		ITEM=ITEM-J
19250		DO 42 IZ=K,ITEM+1
19260		PWDS(IZ)=PWDS(IZ+J)-B
19270	42	IWDS(IZ)=IWDS(IZ+J)-JB
19277		IST2=IST2-JB
19280		J=B
19290		I=I-J
19300		JW=A
19320		CALL LOOP(JW,I,1,0,J,RN)
19330		CALL LOOP(JZ+2,IST2+2,1,0,JB,IST)
19335		IF(K.GE.ITEM)GO TO 1
19337	C  EXITS
19340		NX=K+1
19350		GO TO 142
19450	141	IF(IZ.GE.97)GO TO 9
19475	C   THERE'S A LIMIT TO THE R ARRAY    4/18/73
19500		IZ=IZ+1
19600	C  FOUND AN ITEM
19700		R(1,IZ)=22
19800		R(2,IZ)=NX
19900	10	IZ=IZ+1
20000		IF(RC.EQ.999)GO TO 11
20100		IF(RB.EQ.1)GO TO 30
20200	31	RC=RN(JY+7)
20300		IF(RB.EQ.9)GO TO 32
20400	C  NEXT INVERTS DIP
20405		IF(RX.EQ.1)GO TO 35
20410		A=-1.6
20420		RB=-10
20425		IF(RC)A=-A
20440	36	R(7,IZ)=2
20445		R(8,IZ)=RN(JY+2)+A
20450		GO TO 37
20500	35	RB=-4
20510		IF(RN(JY+8).LT.-1)RB=-1.4
20520	C  2 AND .7 ARE HGTS SET IN 'BEAMS'
20600	37	IF(RC)RB=-RB
20700		R(3,IZ)=4
20800		R(4,IZ)=RN(JY+4)+RB
20900		R(6,IZ)=RN(JY+5)+RB
21000		R(5,IZ)=5
21100	33	R(1,IZ)=7
21200		R(2,IZ)=-RC
21300		GO TO 6
21400	32	IF(RC.LT.20)GO TO 34
21500	C  THIS IS FOR BEAMS
21600		RC=10-RC
21700		GO TO 33
21800	34	RC=-10-RC
21900		GO TO 33
22000	
22200	C  NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
22300	C  MUST! BE FIRST IN LIST!!!
22400	C	RC=0
22500	30	RB=RN(JY+5)
22600		IF(RB.LT.10)GO TO 12
22700	C  NO STEM < 10
22800		RC=10
22900		IF(RB.GE.20)RC=-RC
23000		RB=RB+RC
23100	12	V(1)=5.
23200		V(2)=RB
23300	C  SO IT WILL DISPLAY RESULT
23400	11	DO 8 K=1,8
23500	8	R(K,IZ)=V(K)
23510	6	IF(J)GO TO 45
23600		IF(NX.LT.ITEM)GO TO 140
23700	19	IF(INP(1).NE.'A')GO TO 1
23800	9	R(1,IZ+1)=222
23900		R(1,IZ+2)=0
24000	CC	REND=-1.
24100	1	CALL HYDPOG(3)
24300	CC53	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
24400	55	FORMAT(' TYPE',3(' P#, CHNG ')/)
24500		END
24600	
24700		SUBROUTINE LPEN(A,B,C)
24710		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
24800		COMMON /POSI/STFF(8),JJB,POS /ALF/INP(71),M,L
25100	5	CALL SETCUR(0,100,0)
25200		TYPE 17
25300		ACCEPT F78F,A
25400		IF(A.GE.99)RETURN
25500	C  TYPE 99 TO BACK UP
25600		CALL RDCUR(M,L)
25700		B=(M+512.0)/5.12
25800	C  B=HORIZ. STEP NUM.
25900		CALL CLRCUR
26000		DO 13 K=1,8
26100		M=STFF(K)+60.
26200		IF(L.GT.M)GO TO 13
26300		A=K-4
26400	C  A=STAFF NUM.
26500		GO TO 8
26600	13	CONTINUE
26700	17	FORMAT(' TYPE <CR> TO SET POINT'/)
26900	8	C=IFIX((L-STFF(K)+21.)/7.+.5)
27000	C  FINDS VERT. NOTE NUM.
27100		TYPE F78F,A,B
27300		END
28000	
28100	
28200	
30000		SUBROUTINE DELETE
30100		IMPLICIT INTEGER(A-Q,S-Z)
30200		REAL PWDS
30300		COMMON/DL/X22,SAVER,NAME
30600		COMMON /XRN/RN(4000)
30800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(15),RJF,DEL,X,JY,K
30900		COMMON/PTR/PWDS(250),ITEM,L,I,IX
31000		COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
31100		EQUIVALENCE   (RJD,RJQ(2)),(RJC,RJQ(1)),(ST2,ST(2))
31200	
35400	1	X=ITEM
35500	171	IX=I
35600		L=RN(MEDIT)+3.0
35700	C  SIZE OF DELETION
35800		I=IX-L
35900		CALL LOOP(MEDIT,I,1,0,L,RN)
36000		JY=WDS(X22+1)-WDS(X22)
36100		CALL LOOP(WDS(X22)+2,WDS(X),1,0,JY,ST)
36200		RJF=L
36300		K=X22
36400	194	L=K+1
36500		WDS(L)=WDS(L+1)-JY
36600		PWDS(K)=PWDS(L)-RJF
36700		K=L
36800		IF(K.LT.X)GO TO 194
36900	C  ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
37000		ITEM=ITEM-1
37100		IF(X22.GT.ITEM)X22=ITEM
37300		JB=ITEM
37400		ITEM=ITEM-1
37500	195	ST2=WDS(JB)
37600	271	CALL DPYNEW
37900		END
38000	
38100	
38200		SUBROUTINE DPYNEW
38210		COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
38300		CALL ACCPOG(1)
38400		IF(IGO.GT.0)RETURN
38450		CALL DPYOUT(1)
38600		END
38700	
38800		SUBROUTINE PLTCMD
39000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100		DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200		COMMON /DL/RSIZ,SAVER,NAME /ALF/INP(72),ML
39400		COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700		EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800		1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(NMS(1),INP(31))
39810		1,(RMOV1(1),INP(39))
39855	C  BE CAREFUL OF COMMON OVERLAPS WITH NOTWRT,ITMSUB,HOMER, ETC.
40000	
40100		IF(I2.NE.'L')GO TO 1
40200		I2=0
40300		RXC=0
40400		RMOV1(1)='Y'
40500		NAME=0
40600	14	KA=0
40700	3	KA=KA+1
40715		IF(ML.EQ.0)GO TO 15
40720		K=K-2
40725		ML=ML-1
40730		IF(ML.EQ.0)GO TO 10
40740		GO TO 31
40800	15	TYPE 2,KA
40820		ACCEPT 11,K,ML,RSPC
40860	C  TYPE LAST NAME, NUMBER  FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
41000	50	IF(K.EQ.' ')GO TO 10
41100		IF(K.EQ.'99')GO TO 140
41200	C  99=BACKUP
41300	31	IF(LOOKD(K))GO TO 56
41400	C JUMP IF FILE FOUND
41500		TYPE 55
41600		GO TO 15
41700	55	FORMAT(' FILE NOT FOUND'/)
41750	11	FORMAT(A5,I,F)
41800	56	NMS(KA)=K
41820		IF(ML.EQ.0)GO TO 5
41855		RJH='Y'
41860		IF(RSPC.NE.0)RJH=RSPC
41877		GO TO 21
41900	5	TYPE 8
42000		ACCEPT FA5,RJH
42100		IF(RJH.EQ.'99')GO TO 15
42200		IF(RJH.NE.'Y')RJH=0
42300		IF(RJH.EQ.0)REREAD F78F,RJH
42400	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500	21	RMOV1(KA+1)=RJH
42600		RMOV2(KA)=RJH
42700		GO TO 3
42800	140	KA=KA-1
42900		GO TO 15
43000	
43100	10	KB=KA-1
43200		TYPE 9
43300		ACCEPT F78F,RS
43350		RSIZ=RS
43400		IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500		KA=0
43600	
43700	1	IF(NAME.NE.0)GO TO 12
43800		IF(KA.EQ.KB)CALL EXIT
43900		NAME=NMS(KA+1)
44000		TYPE 111,NAME
44100		RETURN
44200	12	KA=KA+1
44300		NAME=0
44600	C  'PL' = CALCOMP OUTPUT
44700		RJH=0
44800		RJB=RS
44900		RJC=RS
45000		RJG=0
45100		RJE=1
45200		RJF=1
45300		IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400		IF(RMOV1(KA).NE.0)RJE=0
45500		IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600	2	FORMAT(' TYPE FILE NAME',I2,1X$)
45700	8	FORMAT(' MOVE UP AT END? ',$)
45800	9	FORMAT(' SIZE FACTOR? ',$)
45900	111	FORMAT(1XA5/)
46000		END
46100	
46200	C***** SUBRS.  SAVIT, LISTP, FIXUP, KSIG
46300	
46400		SUBROUTINE SAVIT
46500		IMPLICIT INTEGER(A-Q,S-Z)
46600		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
46700		COMMON/DL/X22,SAVER,NAME/POSI/STFF(-3/4),JJB,POS
46800		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
46900		COMMON/ALF/INP(72),ML/XRN/RN(4000)/DPY/ST(4000),WDS(250),MEDIT,IGO
47000		COMMON /STF/RSTFAC(-3/4),RSTJC/PTR/PWDS(250),ITEM,L,I,IX
47100		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
47200		EQUIVALENCE (INP2,INP(2)),(ST2,ST(2))
47300	C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE FOR21.DAT.
47400		IF(SAVER.GE.0)GO TO 10
47500	101	REWIND 21
47600		SAVER=7
47700		GO TO 102
47800	3	FORMAT(' WRITE OVER ',A5,'.DAT?  ',$)
47900	1	FORMAT(I,24F)
48000	2	TYPE 3,NAME
48100		ACCEPT FA1,L
48200		IF(L.NE.'N')GO TO 4
48300	10	IF(INP2.NE.'M')GO TO 11
48400		INP2='B'
48500		GO TO 4
48600	11	TYPE 21
48700		L=NAME
48800		ACCEPT FA5,NAME
48900	C 99 WILL BACK UP.
49000		IF(NAME.NE.'99')GO TO 40
49100		NAME=L
49200		RETURN
49300	40	IF(NAME.NE.'SAME')GO TO 43
49400		NAME=L
49500		GO TO 4
49600	43	IF(LOOKD(NAME))GO TO 2
49700	C  JUMP BACK IF FILE NAME ALREADY ON DSK
49800	4	REWIND 21
49900		IF(NAME.EQ.' ')GO TO 41
50000		CALL OFILE(21,NAME)
50100		GO TO 42
50200	41	NAME=L
50300	42	IF(INP2.EQ.'D')GO TO 202
50400	C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
50500	102	WRITE(21)ITEM,I
50600		1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
50700		1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,L
50800		WRITE(21)RSTFAC,STFF,L
50900	C  TAKE OUT ABOVE NEXT YEAR (12/73)
51000		IF(I.GT.2000)TYPE 20,I
51100		IF(INP2.NE.'B')GO TO 1001
51200		WRITE(21)ST2,(ST(L),L=1,ST2+2),(WDS(L),L=1,ITEM+1)
51300	1001	END FILE 21
51400		IF(INP(1).EQ.'S'.AND.NAME.EQ.' ')TYPE 5600
51500	C   GO BACK IF THE SAVER WROTE THE FILE
51600		RETURN
51700	20	FORMAT(' ****** TOO MUCH DATA TO PRINT - ',I4,'/2000')
51800	202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
51900		GO TO 1001
52000	C   WRITES DPY BUFFER ONLY.
52100	5600	FORMAT(' DISPLAY SAVED IN ''FOR21.DAT'''/)
52300	21	FORMAT(' FILE NAME?  '$)
52400		END
52500	
52600		SUBROUTINE LISTP(LST)
52700		IMPLICIT INTEGER(A-Q,S-Z)
52800		REAL PWDS
52900		DIMENSION LST(13)
53000		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
53100		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(16),K,JY,X,Y
53200		COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
53300		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3))
53400	
53500		CALL NOZERO(RJB)
53600		IF(JC.EQ.0)JC=ITEM
53700		JY=5
53800		IF(JD.NE.0)JY=3
53900		DO 6334 L=IFIX(RJB),JC
54000		X=PWDS(L)
54100		Y=RN(X)+2+X
54200		X=X+1
54300		K=RN(X)
54400		IF(K.EQ.50)K=13
54500		IF(K.EQ.30)K=12
54600		IF(K.EQ.18)K=11
54700	6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
54800		IF(JY.NE.3)RETURN
54900	C  333, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
55000		IF(JE.NE.0)WRITE(JY, 63331),PWDS
55400		RETURN
55600	C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
55900	CCC  FOR INFO ON 'SPOOLF' SEE -- SPSUB[SPL,REG]
56000	63331	FORMAT(8F10.4)
56100	6333	FORMAT(I4,') ',A5,F4.0,F8.3,F4.0,F8.2,7F10.2)
56200		END
56300	
56400	C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
56500		SUBROUTINE FIXUP
56600		COMMON /XRN/RN(4000)/DL/X22,SAVER,NAME
56700		COMMON K,RA,RB,JB,RJ,J,RJQ(38)/PTR/PWDS(250),ITEM,L,I,IX
56800		K=0
56900	2	K=K+1
57000	3	L=PWDS(K)
57100		RA=PWDS(K+1)
57200		RB=RN(L)+3.+L
57300	C  THIS SHOULD BE NEW POINTER
57400		IF(RA-RB.EQ.0)GO TO 6
57500		IF(RN(IFIX(RB))+3+RB.NE.PWDS(K+2))GO TO 8
57600		J=K+1
57700		PWDS(J)=RB
57800		TYPE 10,J
57900		GO TO 6
58000	10	FORMAT(' ?FIXED UP ITEM ',I4)
58100	8	RJ=RA-L
58200		DO 9 JB=K+1,ITEM
58300	9	PWDS(JB)=PWDS(JB+1)-RJ
58400		TYPE 1,K
58500		J=RJ
58600		CALL LOOP(L,I,1,0,J,RN)
58700	C  REARRANGES DATA
58800		I=I-J
58900		ITEM=ITEM-1
59000		IF(ITEM.LE.K)GO TO 7
59100		GO TO 3
59200	C  GO BACK AND TRY AGAIN
59300	6	IF(RA.LE.L)GO TO 8
59400	C  JUMP IF PWDS IS OUT OF ORDER
59500		IF(K.LT.ITEM)GO TO 2
59600	7	SAVER=0
59700		CALL SAVIT
59800	1	FORMAT(' BAD ITEM--',I4/)
59900		END